perm filename IO.SAI[GEO,BGB]1 blob
sn#001325 filedate 1972-10-28 generic text, type T, neo UTF8
00100 ENTRY DUMMY;
00200 BEGIN "IO"
00300 REQUIRE "ABBREV" SOURCE_FILE;
00400 REQUIRE "GEOMES" SOURCE_FILE;
00500
00600 INTEGER OCHN,ICHN,LEVEL,I;
00700 STRING OFILENAME,IFILENAME;
00800 INTEGER BCOUNT,FCOUNT,ECOUNT,VCOUNT;
00900
01000 α AD HOC, BOOTSTRAP, PROTO-TYPE WORLD DIRECTORY;
01100 INTERNAL INTEGER WPTR;
01200 INTERNAL STRING WORLDNAME;
01300 INTERNAL STRING ARRAY NAME [1:50];
01400 INTERNAL INTEGER ARRAY ENTITY [1:50];
01500 INTERNAL INTEGER ARRAY FILE [1:50];
01600 INTERNAL INTEGER ARRAY DSKBLK [1:50];
01700 INTERNAL INTEGER ARRAY PART# [1:50];
01800 INTERNAL INTEGER ARRAY COPAR# [1:50];
01900
02000 EXTERNAL STRING SUBR ISTR(ITG I);
00100 PROCEDURE OPNAME (ITG B);
00200 BEGIN "OPNAME"
00300 ITG N; STRING STR,WORD;
00400 STR ← NAME[PNAME(B)];
00500 N ← LENGTH(STR);
00600 WORDOUT(OCHN,N);
00700 WHILE LENGTH(STR)>0 DO
00800 BEGIN
00900 IF LENGTH(STR)>5 THEN
01000 ⊂ WORD←STR[1 FOR 5];STR←STR[6 FOR ∞];⊃ ELSE
01100 ⊂ WORD←STR;STR←"";⊃;
01200 WORDOUT(OCHN,CVASC(WORD));
01300 END;
01400 END "OPNAME";
01500
01600
01700 PROCEDURE IPNAME(ITG B);
01800 BEGIN "IPNAME"
01900 ITG N,WRDCNT,I;
02000 STRING STR;
02100 N ← WORDIN(ICHN);
02200 WRDCNT ← (N DIV 5) + (IF (N MOD 5)≠0 THEN 1 ELSE 0);
02300 BEGIN
02400 ITG ARRAY WORD[-1:WRDCNT];
02500 ARRYIN(ICHN,WORD[1],WRDCNT);
02600 STR ← "";
02700 FOR I←1 TO WRDCNT DO
02800 STR ← STR & CVSTR(WORD[I]);
02900 STR ← STR[1 TOO N];
03000 NAME[PNAME(B)]←STR;
03100 END;
03200 END "IPNAME";
00100 SUBR OLOCOR (ITG B);
00200 BEGIN "OLOCOR"
00300 ITG I,L;
00400 L ← LOCOR(B);
00500 IF L=0 THEN
00600 FOR I←-3 TO 8 DO WORDOUT(OCHN,0) ELSE
00700 FOR I←-3 TO 8 DO WORDOUT(OCHN,LAC(L+I));
00800 END "OLOCOR";
00900
01000 ITG ARRAY LOCDAT[-3:12];
01100
01200 SUBR ILOCOR (ITG B);
01300 BEGIN "ILOCOR"
01400 ITG I,L,K;
01500 ARRYIN(ICHN,LOCDAT[-3],12);
01600 FOR I←-3 TO 8 DO
01700 IF (LOCDAT[I]≠0) THEN
01800 BEGIN
01900 L ← MKLOCOR;
02000 K ← POINT(36,LOCDAT[0],35);
02100 BLIT(L-3,K-3,12);
02200 LOCOR.(L,B);
02300 RETURN;
02400 END;
02500 END "ILOCOR";
00100 α WORLD DIRECTORY INPUT;
00200 INTERNAL SUBR WORLDI;
00300 BEGIN "WORLDI"
00400 INTEGER FLG,CNT,BRK,EOF,I;
00500 STRING STR,LINE;
00600
00700 α FILE OPENING CEREMONIES;
00800 ICHN←GETCHAN;
00900 OPEN(ICHN,"DSK",0,3,0,CNT,BRK,EOF);
01000 DO ⊂ OUTSTR("NAME.WIX = ");STR←INCHWL;
01100 IF LENGTH(STR)=0 THEN ⊂ RELEASE(ICHN);RETURN;⊃;
01200 LOOKUP(ICHN,STR&".WIX",FLG);
01300 ⊃ UNTIL ¬FLG;
01400
01500 α BREAK ON LINE, IGNORE TABS, SPACE FOR WORD DELIMITER;
01600 BREAKSET(1,↓,"I");
01700 BREAKSET(2," ","I");
01800 BREAKSET(1,9,"O");
01900 α COUNT OF ENTITIES IN THIS WORLD;
02000 CNT←200;LINE ← INPUT(1,1);
02100 WPTR ← INTSCAN(LINE,BRK);
02200
02300 α READ IN WORLD AND STUFF IN TABLES;
02400 FOR I←1 TO WPTR DO
02500 BEGIN
02600 CNT←200;LINE←INPUT(1,1);
02700 STR←SCAN(LINE,2,BRK);
02800 NAME[I]←LINE; α ENTITY NAME;
02900 CNT←200;LINE←INPUT(1,1);
03000 FILE[I]←CVASC(SCAN(LINE,2,BRK)); α FILENAME;
03100 DSKBLK[I]←INTSCAN(LINE,BRK); α DSK FILE BLK NUMBER;
03200 PART#[I]←INTSCAN(LINE,BRK); α WORLD SERIAL NUMBER OF PART;
03300 COPAR#[I]←INTSCAN(LINE,BRK); α WORLD SERIAL NUMBER OF COPART;
03400 END;
03500 RELEASE(ICHN);
03600 OUTSTR(CVS(WPTR)&" ENTITIES - EOF."&↓);
03700 END "WORLDI";
00100 α WORLD DIRECTORY OUTPUT;
00200 INTERNAL SUBR WORLDO;
00300 BEGIN "WORLDO"
00400 INTEGER FLG,I;
00500 OCHN←GETCHAN;
00600 OPEN(OCHN,"DSK",0,0,3,0,0,0);
00700 ENTER(OCHN,WORLDNAME&".WIX",FLG);
00800 OUT(OCHN,CVS(WPTR)&↓);
00900 FOR I←1 TO WPTR DO
01000 BEGIN
01100 OUT(OCHN,CVS(I)&". ");
01200 OUT(OCHN,NAME[I]&↓);
01300 OUT(OCHN,9&CVSTR(FILE[I]));
01400 OUT(OCHN," "&CVS(DSKBLK[I]));
01500 OUT(OCHN," "&CVS(PART#[I]));
01600 OUT(OCHN," "&CVS(COPAR#[I])&↓);
01700 END;
01800 RELEASE(OCHN);
01900 END "WORLDO";
00100 PROCEDURE OFEV (ITG B);
00200 BEGIN "OFEV"
00300 SAFE REAL ARRAY Q[1:3];
00400 ITG F,E,V,WORD,P,N;
00500
00600 α FACES;
00700 F←PFACE(B);
00800 WHILE F≠B DO
00900 ⊂ WORDOUT(OCHN,LAC(F+3));F←PFACE(F); ⊃;
01000
01100 α EDGES;
01200 E←PED(B);
01300 WHILE E≠B DO
01400 BEGIN
01500 N←NFACE(E);P←PFACE(E);
01600 WORD←(SERIAL(N)LSH 18)LOR(SERIAL(P));
01700 WORDOUT(OCHN,WORD);
01800 N←NVT(E);P←PVT(E);
01900 WORD←(SERIAL(N)LSH 18)LOR(SERIAL(P));
02000 WORDOUT(OCHN,WORD);
02100 N←NCW(E);P←PCW(E);
02200 WORD←(SERIAL(N)LSH 18)LOR(SERIAL(P));
02300 WORDOUT(OCHN,WORD);
02400 N←NCCW(E);P←PCCW(E);
02500 WORD←(SERIAL(N)LSH 18)LOR(SERIAL(P));
02600 WORDOUT(OCHN,WORD);
02700 E←PED(E);
02800 END;
02900
03000 α VERTICES;
03100 V←PVT(B);
03200 WHILE V≠B DO
03300 BEGIN
03400 Q[1]←LACR(V-3);
03500 Q[2]←LACR(V-2);
03600 Q[3]←LACR(V-1);
03700 ARRYOUT(OCHN,Q[1],3);
03800 V ← PVT(V);
03900 END;
04000 END "OFEV";
00100 PROCEDURE IFEV (ITG B);
00200 BEGIN "IFEV"
00300 ITG I,F,E,V,Q;
00400 REAL ARRAY XYZ[1:3];
00500 ITG ARRAY FACE[-1:FCOUNT];
00600 ITG ARRAY EDGE[-1:ECOUNT];
00700 ITG ARRAY VERT[-1:VCOUNT];
00800 α MAKE AND INPUT FACES;
00900 FOR I←1 TO FCOUNT DO
01000 BEGIN
01100 F←MKF(B);FACE[I]←F;
01200 Q←WORDIN(ICHN);DAC(Q,F+3);
01300 END;
01400 α MAKE AND INPUT EDGES;
01500 FOR I←1 TO ECOUNT DO
01600 BEGIN
01700 E←MKE(B);EDGE[I]←E;
01800 DAC(WORDIN(ICHN),E+1);
01900 DAC(WORDIN(ICHN),E+3);
02000 DAC(WORDIN(ICHN),E+4);
02100 DAC(WORDIN(ICHN),E+5);
02200 END;
02300 α MAKE AND INPUT VERTICES;
02400 FOR I←1 TO VCOUNT DO
02500 BEGIN
02600 V←MKV(B);VERT[I]←V;
02700 ARRYIN(ICHN,XYZ[1],3);
02800 DACR(XYZ[1],V-3);
02900 DACR(XYZ[2],V-2);
03000 DACR(XYZ[3],V-1);
03100 END;
03200 α CONVERT SERIAL NUMBERS TO NODE NUMBERS;
03300 FOR I←1 TO ECOUNT DO
03400 BEGIN "ELOOP"
03500 E ← EDGE[I];
03600 Q←FACE[CAR(E+1)];DIP(Q,E+1); PED.(E,Q); NCNT.(NCNT(Q)+1,Q);
03700 Q←FACE[CDR(E+1)];DAP(Q,E+1); PED.(E,Q); NCNT.(NCNT(Q)+1,Q);
03800 Q←VERT[CAR(E+3)];DIP(Q,E+3); PED.(E,Q);
03900 Q←VERT[CDR(E+3)];DAP(Q,E+3); PED.(E,Q);
04000 Q←EDGE[CAR(E+4)];DIP(Q,E+4);
04100 Q←EDGE[CDR(E+4)];DAP(Q,E+4);
04200 Q←EDGE[CAR(E+5)];DIP(Q,E+5);
04300 Q←EDGE[CDR(E+5)];DAP(Q,E+5);
04400 END "ELOOP";
04500 END "IFEV";
00100 INTERNAL SUBR RESERIAL (ITG B);
00200 BEGIN "RESERIAL"
00300 ITG F,E,V,I;
00400 IF ¬BTYPE(B) THEN RETURN;
00500 α FACES;
00600 F←NFACE(B);IF SERIAL(F)≠FCNT(B) THEN
00700 ⊂ I←1;F←PFACE(B);
00800 WHILE F≠B DO
00900 ⊂ SERIA.(I,F);INCREM(I);F←PFACE(F);⊃;⊃;
01000 α EDGES;
01100 E←NED (B);IF SERIAL(E)≠ECNT(B) THEN
01200 ⊂ I←1;E←PED (B);
01300 WHILE E≠B DO
01400 ⊂ SERIA.(I,E);INCREM(I);E←PED (E);⊃;⊃;
01500 α VERTICES;
01600 V←NVT (B);IF SERIAL(V)≠VCNT(B) THEN
01700 ⊂ I←1;V←PVT (B);
01800 WHILE V≠B DO
01900 ⊂ SERIA.(I,V);INCREM(I);V←PVT (V);⊃;⊃;
02000 END "RESERIAL";
00100 SUBR OB (ITG B);
00200 BEGIN "OB"
00300 RESERIAL(B);
00400 FILE[PNAME(B)] ← CVASC(OFILENAME);
00500 WORDOUT(OCHN,FCNT(B));
00600 WORDOUT(OCHN,ECNT(B));
00700 WORDOUT(OCHN,VCNT(B));
00800 OPNAME(B);
00900 OLOCOR(B);
01000 OFEV(B);
01100 OUTCHR(9);
01200 FOR I←1 TO LEVEL DO OUTSTR(" ");
01300 OUTSTR(NAME[PNAME(B)]&↓);
01400 END "OB";
01500
01600 SUBR IB (ITG B);
01700 BEGIN "IB"
01800 FILE[PNAME(B)] ← CVASC(IFILENAME);
01900 FCOUNT ← WORDIN(ICHN);
02000 ECOUNT ← WORDIN(ICHN);
02100 VCOUNT ← WORDIN(ICHN);
02200 IPNAME(B);
02300 ILOCOR(B);
02400 IFEV(B);
02500 OUTCHR(9);
02600 FOR I←1 TO LEVEL DO OUTSTR(" ");
02700 OUTSTR(NAME[PNAME(B)]&↓);
02800 END "IB";
00100 RECURSIVE PROCEDURE OBODY (ITG B0);
00200 BEGIN "OBODY"
00300 ITG B;
00400 INCREM(LEVEL);
00500 WORDOUT(OCHN,PCNT(B0)+1);
00600 α OUTPUT THE BODY ITSELF;
00700 OB(B0); B ← PART(B0);
00800 α OUTPUT THE PARTS OF THIS BODY;
00900 WHILE B>0 DO ⊂ OBODY(B); B←COPART(B);⊃;
01000 DECREM(LEVEL);
01100 END "OBODY";
01200
01300
01400 RECURSIVE ITG PROCEDURE IBODY (ITG B0);
01500 BEGIN "IBODY"
01600 ITG B,I,PCOUNT;
01700 INCREM(LEVEL);
01800 PCOUNT ← WORDIN(ICHN);
01900 IF PCOUNT=0 THEN
02000 ⊂ DECREM(LEVEL);RETURN(0);⊃; α AIN'T NO BODY THERE;
02100 DECREM(PCOUNT);
02200 α INPUT THE BODY ITSELF;
02300 B ← MKB(B0);
02400 RINGIN(B,WORLD,#ALBODY);
02500 INCREM(WPTR);
02600 ENTITY[WPTR]←B;
02700 PNAME.(WPTR,B);
02800 NAME[WPTR]←"B"&CVS(SERIAL(B));
02900 IB(B);
03000 α INPUT THE PARTS OF THIS BODY;
03100 FOR I←1 STEP 1 UNTIL PCOUNT DO IBODY(B);
03200 α UPDATE WORLD DIRECTORY;
03300 PART#[PNAME(B)] ←
03400 IF PART(B)<0 THEN -PNAME(-PART(B)) ELSE PNAME(PART(B));
03500 COPAR#[PNAME(B)] ←
03600 IF COPART(B)<0 THEN -PNAME(-COPART(B)) ELSE PNAME(COPART(B));
03700 DECREM(LEVEL);
03800 RETURN(B);
03900 END "IBODY";
00100 INTERNAL SUBR OFILE (ITG B);
00200 BEGIN "OFILE"
00300 ITG FLG; STRING STR;
00400
00500 IF ¬BTYPE(B) THEN RETURN;
00600 α FILE OPENING CEREMONIES;
00700 OCHN←GETCHAN;
00800 OPEN(OCHN,"DSK",8,0,3,0,0,0);
00900 STR ← NAME[PNAME(B)];
01000 IF LENGTH(STR)>6 THEN STR←STR[1 TOO 6];
01100 ENTER(OCHN,STR&".B3D",FLG);
01200 OUTSTR(↓);
01300 OFILENAME←STR;
01400 OBODY(B);
01500 RELEASE(OCHN);
01600 WORLDO;
01700 OUTSTR("EOF - "&STR&".B3D"&↓);
01800 END "OFILE";
01900
02000 INTERNAL ISUBR IFILE (ITG B0; STRING STR);
02100 BEGIN "IFILE"
02200 ITG FLG,I;
02300
02400 α FILE OPENING CEREMONIES;
02500 ICHN←GETCHAN;
02600 OPEN(ICHN,"DSK",8,3,0,0,0,0);
02700 IFILENAME ← STR;
02800 IF LENGTH(IFILENAME)=0 THEN
02900 DO ⊂ OUTSTR(" FILE = ");IFILENAME←INCHWL;
03000 IF LENGTH(IFILENAME)=0 THEN
03100 ⊂ RELEASE(ICHN);RETURN(0);⊃;
03200 LOOKUP(ICHN,IFILENAME,FLG);
03300 IF FLG THEN LOOKUP(ICHN,IFILENAME&".B3D",FLG);
03400 ⊃ UNTIL ¬FLG;
03500
03600 α READ ALL DEM BODIES;
03700 I ← IBODY(B0);
03800 RELEASE(ICHN);
03900 OUTSTR("EOF - "&IFILENAME&↓&"*");
04000 RETURN(I);
04100 END "IFILE";
04200 END "IO";
04300 IO.SAI - EOF.